home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / EDIT.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  26.8 KB  |  839 lines
  1. ; EDIT.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Scheme Structure Editor                    *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: Paul Kristoff        Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22.  
  23. (define edit
  24.   (letrec ((read-eval-print-loop
  25.         (letrec ((read-command
  26.                (lambda ()
  27.              (print 'EDIT->)
  28.              (set! buffer (read))
  29.              (if (atom? buffer)
  30.                  (set! buffer (list (list buffer)))
  31.                  (if (atom? (car buffer))
  32.                  (set! buffer (list buffer))))))
  33.              (do-command
  34.                (lambda ()
  35.              (if (or (number? (car command))
  36.                  (eq? (car command) '*))
  37.                  (move (car command))
  38.                  (case (car command)
  39.                    ((?)  (print
  40.                        (print-depth-length fp 2 10)))
  41.                    ((P)  (print fp))
  42.                    ((??) (pp
  43.                        (print-depth-length fp 2 10)))
  44.                    ((PP) (pp fp))
  45.                    ((N)  (next))
  46.                    ((PR) (previous))
  47.                    ((B)  (beginning))
  48.                    ((T)  (top))
  49.                    ((F)  (find (cadr command)))
  50.                    ((IB) (insert-before
  51.                        (cadr command)
  52.                        (caddr command)))
  53.                    ((IA) (insert-after
  54.                        (cadr command)
  55.                        (caddr command)))
  56.                    ((SB) (splice-before
  57.                        (cadr command)
  58.                        (caddr command)))
  59.                    ((SA) (splice-after
  60.                        (cadr command)
  61.                        (caddr command)))
  62.                    ((D)  (delete (cadr command)))
  63.                    ((DP) (delete-parentheses
  64.                        (cadr command)))
  65.                    ((AP) (add-parentheses
  66.                        (cadr command)
  67.                        (caddr command)))
  68.                    ((S)  (substitute
  69.                        (cadr command)
  70.                        (caddr command)))
  71.                    ((R)  (replace
  72.                        (cadr command)
  73.                        (caddr command)))
  74.                    ((PS) (ps))
  75.                    ((MAC?) (mac? (cadr command)))
  76.                    ((MAC) (create-ed-macro
  77.                         (cadr command)
  78.                         (caddr command)))
  79.                    ((Q)  (set! done? #T))
  80.                    (else (if (ed-macro? (car command))
  81.                          (expand-mac command)
  82.                          (begin
  83.                            (newline)
  84.                            (set! buffer '())
  85.                            (writeln
  86.                          "  ?  Unknown command: "
  87.                          command))))
  88.                   ))))
  89.              (mac?
  90.                (lambda (name)
  91.              (let ((temp (ed-macro? name)))
  92.                (if (null? temp)
  93.                    (begin (writeln name " is not a macro.")
  94.                       '())
  95.                    (pp (list 'mac (list name (car temp))
  96.                           (cdr temp)))))))
  97.              (ed-macro?
  98.                (lambda (name)
  99.              (and (symbol? name)
  100.                   (getprop name 'ed*macro))))
  101.              (expand-mac
  102.                (lambda (com)
  103.              (let* ((x (getprop (car com) 'ed*macro))
  104.                 (eem (expand-ed-macro
  105.                     (cdr com)
  106.                     (car x)
  107.                     (cdr x))))
  108.                 (if (eq? eem 'error)
  109.                 (begin (set! buffer '())
  110.                        (writeln "  ?  Error with macro"
  111.                         command))
  112.                 (set! buffer
  113.                       (append eem buffer))))))
  114.              (create-ed-macro
  115.                (lambda (name&nargs expan)
  116.              (putprop (car name&nargs)
  117.                   (cons (cadr name&nargs)
  118.                     expan)
  119.                   'ed*macro)))
  120.              (expand-ed-macro
  121.             (lambda (args nargs expan)
  122.               (letrec
  123.                 ((loop
  124.                    (lambda (expan)
  125.                  (cond ((null? expan) '())
  126.                        ((atom? expan)
  127.                     (let ((n (arg? expan)))
  128.                       (if n
  129.                           (list-ref args (-1+ n))
  130.                           expan)))
  131.                        ((atom? (car expan))
  132.                      (let ((n (arg? (car expan))))
  133.                        (cons (if n
  134.                              (list-ref args
  135.                                (-1+ n))
  136.                              (car expan))
  137.                          (loop (cdr expan)))))
  138.                        (else (cons (loop (car expan))
  139.                         (loop (cdr expan)))))))
  140.                  )
  141.                 (if (= (length args) nargs)
  142.                 (loop expan)
  143.                 'error))))
  144.              )
  145.           (lambda ()
  146.         (if (not (memq (car command) '(P ? PP ??)))
  147.             (print (print-depth-length fp 2 10)))
  148.         (if (not done?)
  149.             (begin (read-command)
  150.                (do ()
  151.                    ((null? buffer))
  152.                    (set! command (car buffer))
  153.                    (when (atom? command)
  154.                  (set! command (list command)))
  155.                    (set! buffer (cdr buffer))
  156.                    (do-command))
  157.                (read-eval-print-loop))
  158.             (begin (top) fp)))))
  159.  
  160.  
  161.  
  162. ;--------------------------------------------------------------------;
  163. ; MOVE                                     ;
  164. ;  Argument: integer or *                         ;
  165. ;    Move repositions the fp to be the nth element of the current    ;
  166. ;    fp.  If an integer is positive the nth element will be from     ;
  167. ;    the left.    If the number is too large then the fp is moved to   ;
  168. ;    last element from the left.  If negative the nth element will   ;
  169. ;    be from the right.  If the absolute value of the number is      ;
  170. ;    larger than the number of elements in the fp, then the fp is    ;
  171. ;    repositioned to the 1st element from the left.  If the the      ;
  172. ;    argument is *, the fp is repositioned to be the cdr of the      ;
  173. ;    cons cell of the fp.                         ;
  174. ;--------------------------------------------------------------------;
  175.  
  176.        (move
  177.          (let ((stop (lambda ()
  178.                (newline)
  179.                (writeln "  ?  Cannot do a Move on an atom."))))
  180.            (lambda (n)
  181.          (cond ((atom? fp) (stop))
  182.                ((eq? n '*)
  183.             (begin (push fp '*)
  184.                    (set! fp (cdr (last-pair fp)))
  185.                    fp))
  186.                (else (let ((num (correct-position n)))
  187.                 (cond ((null? n) (circular num))
  188.                   ((<= num 0) (push fp 1)
  189.                           (set! fp (car fp)))
  190.                   (else (let ((smart-list
  191.                          (smart-list-ref
  192.                         fp (-1+ num))))
  193.                        (push fp
  194.                          (- num (cdr smart-list)))
  195.                        (set! fp (car smart-list))
  196.                        fp)))))))))
  197.  
  198. ;--------------------------------------------------------------------;
  199. ;  BEGINNING                                 ;
  200. ;   No arguments                             ;
  201. ;   Repositions the fp to be the parent of the current fp         ;
  202. ;--------------------------------------------------------------------;
  203.        (beginning
  204.          (let ((stop (lambda ()
  205.                (newline)
  206.                (writeln "  ?  Already at top level."))))
  207.            (lambda ()
  208.          (if (at-top-level?)
  209.              (stop)
  210.            (let ((stack-frame (pop)))
  211.              (set! fp (fp-part stack-frame))
  212.              fp)))))
  213.  
  214. ;--------------------------------------------------------------------;
  215. ;  NEXT                                  ;
  216. ;  No Arguments                                 ;
  217. ;  Moves the fp to be the next element to the right of the parent    ;
  218. ;  of the current fp.  If the fp is pointing to the last element,    ;
  219. ;  the fp remains the same.                         ;
  220. ;--------------------------------------------------------------------;
  221.  
  222.        (next
  223.          (let ((stop (lambda ()
  224.                (newline)
  225.                (writeln
  226.                    "  ?  There is no Next from this position")))
  227.            (stop1
  228.              (lambda ()
  229.                (newline)
  230.                (writeln
  231.              "  ?  Can't execute Next command at top level"))))
  232.            (lambda ()
  233.          (if (at-top-level?)
  234.              (stop1)
  235.            (let ((stack-frame (pop)))
  236.              (set! fp (fp-part stack-frame))
  237.              (move (if (eq? (element-part stack-frame) '*)
  238.                    (begin (stop) '*)
  239.                  (1+ (element-part stack-frame))))
  240.              fp)))))
  241.  
  242. ;--------------------------------------------------------------------;
  243. ;  PREVIOUS                                 ;
  244. ;  No Arguments                              ;
  245. ;  Repositions the fp to be the previous element of the parent of    ;
  246. ;  the current fp.  If already at the first element of the fp, then  ;
  247. ;  the fp remains the same.                         ;
  248. ;--------------------------------------------------------------------;
  249.        (previous
  250.          (let ((stop (lambda ()
  251.                (newline)
  252.                (writeln
  253.                  "  ?  There is no Previous from this position")))
  254.            (stop1 (lambda ()
  255.                 (newline)
  256.                 (writeln
  257.                   "  ?  Can't execute Previous at top level"))))
  258.            (lambda ()
  259.          (if (at-top-level?)
  260.              (stop1)
  261.            (let ((stack-frame (pop)))
  262.              (set! fp (fp-part stack-frame))
  263.              (move (cond ((eq? (element-part stack-frame) '*)
  264.                   (begin (stop) '*))
  265.                  ((= (element-part stack-frame) 1) (stop) 1)
  266.                  (else (-1+ (element-part stack-frame)))))
  267.              fp)))))
  268.  
  269. ;--------------------------------------------------------------------;
  270. ;  TOP                                     ;
  271. ;  No arguments                              ;
  272. ;  Sets the fp to point to the car of very-top.  Resets the stack.   ;
  273. ;--------------------------------------------------------------------;
  274.        (top
  275.          (lambda ()
  276.            (set! fp (car very-top))
  277.            (set! stack initial-stack)
  278.            ))
  279. ;--------------------------------------------------------------------;
  280. ;   FIND                                 ;
  281. ;   Can take an argument                         ;
  282. ;   Searches beginning with the FP (not including the FP) until the  ;
  283. ;   it either finds the pfv (using equal?) or the whole stack is     ;
  284. ;   popped.  If it is found the FP is moved to that point.  If is    ;
  285. ;   it is not the FP and STACK remain the same.  The value maybe     ;
  286. ;   inside the FP.                             ;
  287. ;--------------------------------------------------------------------;
  288.        (find
  289.          (letrec ((find-next
  290.             (lambda ()
  291.               (cond ((equal? fp pfv) (set! found? #T))
  292.                 ((atom? fp) (get-next-element))
  293.                 (else (move 1)
  294.                    (find-next)))))
  295.               (get-next-element
  296.             (let ((stop (lambda ()
  297.                       (newline)
  298.                       (writeln "  ?  Did not find "
  299.                            pfv))))
  300.               (lambda ()
  301.                 (if (at-top-level?)
  302.                 (stop)
  303.                   (let ((stack-frame (pop)))
  304.                 (let ((tfp (fp-part stack-frame))
  305.                       (tel (element-part
  306.                          stack-frame)))
  307.                   (if (eq? tel '*)
  308.                       (get-next-element)
  309.                       (let ((next-element
  310.                           (list-ref-* tfp tel)))
  311.                     (push tfp
  312.                           (if (eq? (cdr next-element)
  313.                                '*)
  314.                           '*
  315.                           (1+ tel)))
  316.                     (set! fp
  317.                           (car next-element))
  318.                     (find-next)))
  319.                   ))))))
  320.               (temp-stack '())
  321.               (temp-fp '())
  322.               (found? #F)
  323.               (pfv '**unbound**)
  324.               )
  325.            (lambda v
  326.          (if (not (null? (car v)))
  327.              (set! pfv (car v)))
  328.          (set! found? #F)
  329.          (set! temp-stack stack)
  330.          (set! temp-fp fp)
  331.          (if (atom? fp)         ; allows find next if fp is
  332.              (get-next-element)     ; equal to the pfv
  333.              (begin (move 1) (find-next)))
  334.          (if (not found?)
  335.              (let ((par (parent stack)))
  336.                (set! stack temp-stack)
  337.                (set! fp temp-fp)))
  338.          fp)))
  339. ;--------------------------------------------------------------------;
  340. ;  REPLACE                                 ;
  341. ;  arguments n:  The element being replaced (nth element of the FP). ;
  342. ;         v:  The value the nth element will replace.         ;
  343. ;  Replace will replace the nth element of the FP with v.  n can be  ;
  344. ;  either negative or positive.  If too large an error is indicated. ;
  345. ;--------------------------------------------------------------------;
  346.        (replace
  347.          (lambda (n v)
  348.            (cond ((eq? n '*) (set-cdr! (last-pair fp) v))
  349.              ((not (number? n))
  350.               (newline)
  351.               (writeln "  ?  Non-number or non-* to Replace: " n))
  352.              ((= n 0) (correct-stack v)
  353.               (set! fp v))
  354.              (else (let ((num (correct-position n)))
  355.               (if (null? num)
  356.                   (circular-error n)
  357.                   (let ((sc (smart-list-tail
  358.                       fp
  359.                       (-1+ num))))
  360.                 (if (atom? sc)
  361.                     (not-enough-elements-error n)
  362.                     (set-car! sc v)))))))))
  363. ;--------------------------------------------------------------------;
  364. ;  SUBSTITUTE                                 ;
  365. ;  arguments for :  The value searched for.                 ;
  366. ;         this:  The value that replaces the value searched for   ;
  367. ;  Searches the FP for 'for'.  It replaces all occurrences of 'for'  ;
  368. ;  with 'this'.  If none are found it will indicate that.            ;
  369. ;--------------------------------------------------------------------;
  370.        (substitute
  371.          (lambda (for this)
  372.            (letrec ((found? #F)
  373.             (subst
  374.               (lambda (l)
  375.                 (cond ((null? l) '())
  376.                   ((equal? for l) (set! found? #T) this)
  377.                   ((atom? l) l)
  378.                   (else (cons (subst (car l))
  379.                        (subst (cdr l)))))))
  380.             )
  381.           (set! fp (subst fp))
  382.           (if (not found?)
  383.               (begin (newline)
  384.                  (writeln "  ?  Can't find " for))
  385.               (correct-stack fp))
  386.           fp)))
  387.        (delete
  388.          (lambda (n)
  389.            (cond ((eq? n '*) (set-cdr! (last-pair fp) '()))
  390.              ((not (number? n))
  391.               (newline)
  392.               (writeln "  ?  Non-number or non-* to Delete: " n))
  393.              ((zero? n) (set! fp '()) (correct-stack fp))
  394.              (else (let ((num (correct-position n)))
  395.               (cond ((null? num) (circular-error n))
  396.                 ((atom? fp)
  397.                  (newline)
  398.                  (writeln
  399.                    "  ?  FP is an atom, can't delete "
  400.                    n " element"))
  401.                 ((= num 1)
  402.                   (set! fp (cdr fp))
  403.                   (correct-stack fp))
  404.                 (else (let ((sc (smart-list-tail fp (- num 2)))
  405.                      (scc (smart-list-tail fp num)))
  406.                      (if (and (atom? scc)
  407.                           (not (null? scc))) ;PRK 53085
  408.                      (not-enough-elements-error n)
  409.                      (set-cdr! sc scc))))))))))
  410. ;--------------------------------------------------------------------;
  411. ;  DELETE PARENTHESES                             ;
  412. ;  argument n:    The nth element of the FP                 ;
  413. ;  Deletes the parentheses from around the nth element of the FP.    ;
  414. ;  The nth element must be a list otherwise an error will occur.  n  ;
  415. ;  maybe either negative or positive.                     ;
  416. ;--------------------------------------------------------------------;
  417.        (delete-parentheses
  418.          (lambda (n)
  419.            (letrec ((stop1
  420.               (lambda ()
  421.                 (newline)
  422.                 (writeln
  423.                  "  ?  Can't delete parentheses for this position "
  424.                   n)))
  425.             (stop2 (lambda ()
  426.                  (newline)
  427.                  (writeln "  ?  Element is not a list")))
  428.             )
  429.           (if (and (number? n) (not (zero? n)))
  430.               (let* ((num (correct-position n)))
  431.             (if (null? num)
  432.                 (circular-error n)
  433.                 (let ((elem (smart-list-ref fp (-1+ num)))
  434.                   (next-elem (smart-list-tail fp num))
  435.                   )
  436.                   (when (eq? next-elem '*atom-returned*)
  437.                 (set! next-elem '()))
  438.                   (cond ((atom? fp)
  439.                      (newline)
  440.                      (writeln
  441.                        "  ?  FP is an atom, can't delete "
  442.                        n " element."))
  443.                     ((not (zero? (cdr elem)))
  444.                      (not-enough-elements-error n))
  445.                     ((not (list? (car elem)))
  446.                      (stop2))
  447.                     ((= num 1)
  448.                      (set! fp (append! (car elem) next-elem))
  449.                      (correct-stack fp))
  450.                     (else (set-cdr! (list-tail fp (- num 2))
  451.                      (append! (car elem) next-elem)))))))
  452.               (stop1))
  453.           )))
  454. ;--------------------------------------------------------------------;
  455. ;  ADD PARENTHESES                             ;
  456. ;  arguments x:  One or two arguments                     ;
  457. ;  Will add parentheses from the first argument to the second         ;
  458. ;  argument (left to right).  The first argument must be to the left ;
  459. ;  or the same as the second argument.    If the first argument is * or;
  460. ;  0 (zero) the second argument is ignored.                 ;
  461. ;--------------------------------------------------------------------;
  462.        (add-parentheses
  463.          (lambda x
  464.            (let ((m (car x))(n (cadr x)))
  465.          (cond ((atom? fp)
  466.             (newline)
  467.             (writeln
  468.               "  ?  FP is an atom, can't Add Parentheses"))
  469.                ((eq? m '*)
  470.             (let ((lp (last-pair fp)))
  471.               (set-cdr! lp (list (cdr lp)))))
  472.                ((not (number? m))
  473.             (newline)
  474.             (writeln
  475.                 "  ?  Non-number or non-* to Add Parentheses:  "
  476.                 m))
  477.                ((= m 0) (set! fp (cons fp '()))
  478.             (correct-stack fp))
  479.                ((eq? n '*)
  480.             (let ((cm (correct-position m)))
  481.               (cond ((null? cm)(circular-error m))
  482.                 ((= cm 1) (set! fp (cons fp '()))
  483.                  (correct-stack fp))
  484.                 (else (let ((slt1
  485.                        (smart-list-tail fp (- cm 2)))
  486.                      (slt2
  487.                        (smart-list-tail fp (-1+ cm))))
  488.                      (if (atom? slt2)
  489.                      (not-enough-elements-error m)
  490.                        (set-cdr! slt1
  491.                          (cons slt2 '()))))))))
  492.                ((not (number? n))
  493.             (newline)
  494.             (writeln
  495.                 "  ?  Non-number or non-* to Add Parentheses: "
  496.                 n))
  497.                (else (let ((cm (correct-position m))
  498.                 (cn (correct-position n)))
  499.                 (cond ((null? cm) (circular-error m))
  500.                   ((null? cn) (circular-error n))
  501.                   ((<= cm 0) (not-enough-elements-error m))
  502.                   ((<= cn 0) (not-enough-elements-error n))
  503.                   ((> cm cn)
  504.                    (newline)
  505.                    (writeln
  506.                      "  ?  First argument, " m
  507.             " is positioned to the right of the 2nd, " n))
  508.                   (else (let ((end-fp (list-tail fp  cn))
  509.                        (last-arg-tail
  510.                          (smart-list-tail fp (-1+ cn))))
  511.                        (if (atom? last-arg-tail)
  512.                        (not-enough-elements-error n)
  513.                      (begin (set-cdr! last-arg-tail '())
  514.                         (if (= cm 1)
  515.                             (begin
  516.                               (set! fp
  517.                                 (cons fp end-fp))
  518.                               (correct-stack fp))
  519.                           (set-cdr!
  520.                             (list-tail fp (- cm 2))
  521.                             (cons
  522.                               (list-tail fp (-1+ cm))
  523.                               end-fp))))))))))
  524.                ))))
  525. ;--------------------------------------------------------------------;
  526. ;  SPLICE BEFORE                             ;
  527. ;  arguments n:  The nth element of the FP                 ;
  528. ;         v:  The list of values to be spliced before the nth     ;
  529. ;         element.                         ;
  530. ;  Splices before the nth element of the FP, the elements in v.  If  ;
  531. ;  v is not a list an error is indicated.                 ;
  532. ;--------------------------------------------------------------------;
  533.        (splice-before
  534.          (lambda (n v)
  535.            (cond ((atom? fp)
  536.               (newline)
  537.               (writeln
  538.             "  ?  FP is an atom, can't splice before "
  539.             n " element"))
  540.              ((or (not (number? n)) (zero? n))
  541.               (newline)
  542.               (writeln
  543.                   "  ?  First argument must be a non-zero integer: "
  544.                    n))
  545.              ((not (list? v))
  546.               (newline)
  547.               (writeln "  ?  Second argument must be a list: " v))
  548.              (else (let ((num (correct-position n)))
  549.               (cond ((null? num)
  550.                  (circular-error n))
  551.                 ((= num 1)
  552.                  (set! fp (append! v fp))
  553.                  (correct-stack fp))
  554.                 (else (let ((slt1
  555.                        (smart-list-tail fp (- num 2)))
  556.                      (slt2
  557.                        (smart-list-tail fp (-1+ num))))
  558.                      (if (atom? slt2)
  559.                      (not-enough-elements-error n)
  560.                      (set-cdr! slt1
  561.                            (append! v slt2))))))))
  562.                )))
  563. ;--------------------------------------------------------------------;
  564. ;  SPLICE AFTER                              ;
  565. ;  arguments n:  The nth element of the FP.                 ;
  566. ;         v:  The list of elements that are splice after the nth  ;
  567. ;         element.                         ;
  568. ;  The elements of v are placed after the nth element of the FP.  If ;
  569. ;  v is not a list an error is indicated.                 ;
  570. ;--------------------------------------------------------------------;
  571.        (splice-after
  572.          (lambda (n v)
  573.            (cond ((atom? fp)
  574.               (newline)
  575.               (writeln
  576.             "  ?  FP is an atom, can't splice after "
  577.             n " element"))
  578.              ((or (not (number? n)) (zero? n))
  579.               (newline)
  580.               (writeln
  581.                   "  ?  First argument must be a non-zero integer: "
  582.               n))
  583.              ((not (list? v))
  584.               (newline)
  585.               (writeln "  ?  Second argument must be a list: " v))
  586.              (else (let ((num (correct-position n)))
  587.               (if (null? num)
  588.                   (circular-error n)
  589.                   (let ((slt1 (smart-list-tail fp (-1+ num)))
  590.                     (slt2 (smart-list-tail fp num)))
  591.                 (if (atom? slt1)
  592.                     (not-enough-elements-error n)
  593.                     (set-cdr! slt1
  594.                           (append! v slt2)))))))
  595.              )))
  596. ;--------------------------------------------------------------------;
  597. ;  INSERT BEFORE                             ;
  598. ;  arguments num:  The nth element of the FP                 ;
  599. ;         v    :  The value being placed before the nth element     ;
  600. ;  Makes sure that the v can be inserted the calls splice-before     ;
  601. ;  with num and (list v).                         ;
  602. ;--------------------------------------------------------------------;
  603.        (insert-before
  604.          (lambda (num v)
  605.            (cond ((atom? fp)
  606.               (newline)
  607.               (writeln
  608.             "  ?  FP is an atom, can't insert before "
  609.             n " element"))
  610.              (else (splice-before num (cons v '()))))))
  611. ;--------------------------------------------------------------------;
  612. ;  INSERT AFTER                              ;
  613. ;  arguments num:  The nth element of the FP                 ;
  614. ;         v    :  The value being placed after the nth element      ;
  615. ;  Makes sure that the v can be inserted the calls splice-after      ;
  616. ;  with num and (list v).                         ;
  617. ;--------------------------------------------------------------------;
  618.        (insert-after
  619.          (lambda (num v)
  620.            (cond ((atom? fp)
  621.               (newline)
  622.               (writeln
  623.             "  ?  FP is an atom, can't insert after "
  624.             n " element"))
  625.              (else (splice-after num (cons v '()))))))
  626. ;--------------------------------------------------------------------;
  627. ;                                     ;
  628. ;               Help Functions                 ;
  629. ;                                     ;
  630. ;--------------------------------------------------------------------;
  631.  
  632.        (push
  633.          (lambda (l pos)
  634.            (set! stack (cons (list* l pos) stack))))
  635.  
  636.        (pop
  637.          (lambda ()
  638.            (if (null? (cdr stack))
  639.            'cannot-pop-stack
  640.          (begin0 (car stack)
  641.              (set! stack (cdr stack))))))
  642.  
  643.        (fp-part car)
  644.  
  645.        (element-part cdr)
  646.       ;----------------------------------------------------------;
  647.       ;  Print depth length                      ;
  648.       ;  It will return a list with depth of print-level and     ;
  649.       ;  length of print-length.  It will replace all levels     ;
  650.       ;  lower than print-level with # and all elements further  ;
  651.       ;  than print-length with ...                  ;
  652.       ;----------------------------------------------------------;
  653.  
  654.        (print-depth-length
  655.          (letrec ((p1 0)
  656.               (loop
  657.             (lambda (l lev len)
  658.               (cond ((<= len 0) '(...))
  659.                 ((atom? l) l)
  660.                 ((<= lev 0) '#\#)
  661.                 ((atom? (car l))
  662.                  (cons (car l)
  663.                        (loop (cdr l) lev (-1+ len))))
  664.                 (else (cons (loop (car l) (-1+ lev) p1)
  665.                      (loop (cdr l) lev (-1+ len)))))))
  666.               )
  667.            (lambda (l print-level print-length)
  668.          (set! p1 print-length)
  669.          (loop l print-level print-length) )))
  670.  
  671.        (list-length     ; Gives list-length while checking for
  672.          (lambda (l)           ; circular lists. Returns '()
  673.            (letrec ((loop (lambda ()  ; if circular list is found
  674.                 (cond ((atom? fast) n)
  675.                       ((atom? (cdr fast)) (+ n 1))
  676.                       ((and (eq? fast slow) (> n 0)) '())
  677.                       (else (set! fast (cddr fast))
  678.                      (set! slow (cdr slow))
  679.                      (set! n (+ n 2))
  680.                      (loop)))))
  681.           (n 0)
  682.           (fast l)
  683.           (slow l))
  684.                (loop))))
  685.  
  686.        (correct-position    ; If number is negative, translates it
  687.          (lambda (n)           ; the equivalent positive number.
  688.            (if (< n 0)
  689.            (+ (list-length fp) (1+ n))
  690.            n)))
  691.  
  692.       ;----------------------------------------------------------;
  693.       ;  Smart-list-ref                         ;
  694.       ;  Returns a pair.  The first of which is the list-ref of  ;
  695.       ;  l.  The second is the number left over.  This number    ;
  696.       ;  will be zero unless the number is larger than the number;
  697.       ;  of elements in the list.  Then it will show the number  ;
  698.       ;  left and return the last element.                 ;
  699.       ;----------------------------------------------------------;
  700.        (smart-list-ref
  701.          (lambda (l n)
  702.            (cond ((atom? l) '())
  703.              ((atom? (cdr l)) (cons (car l) n))
  704.              ((zero? n) (cons (car l) 0))
  705.              (else (smart-list-ref (cdr l) (-1+ n))))))
  706.  
  707.        (at-top-level?
  708.          (lambda () (null? (cdr stack))))
  709.       ;----------------------------------------------------------;
  710.       ;  Correct-stack                         ;
  711.       ;  Corrects the parent of the FP when the FP is changed    ;
  712.       ;  with a set! instead of set-car! or set-cdr!         ;
  713.       ;----------------------------------------------------------;
  714.  
  715.        (correct-stack
  716.          (lambda (l)
  717.            (let ((par (parent stack)))
  718.          (if (eq? (element-part par) '*)
  719.              (if (atom? l)
  720.              (set-cdr! (last-pair (fp-part par)) l)
  721.              (let ((stack-frame (pop)))
  722.                (set! fp (fp-part stack-frame))
  723.                (set-cdr! (last-pair fp) l)))
  724.              (set-car! (if (= (element-part par) 1)
  725.                    (fp-part par)
  726.                    (list-tail (fp-part par)
  727.                           (-1+ (element-part par))))
  728.                    l)))))
  729.  
  730.        (list?
  731.          (lambda (l)
  732.            (and (pair? l)
  733.             (null? (cdr (last-pair l))))))
  734.  
  735.       ;----------------------------------------------------------;
  736.       ;  List-ref-*                          ;
  737.       ;  Used in Find.  It is set up to know about the *th         ;
  738.       ;  position.    It counts the * as another element.  Other   ;
  739.       ;  than this, it is just like smart-list-ref.          ;
  740.       ;----------------------------------------------------------;
  741.        (list-ref-*
  742.          (lambda (l n)
  743.            (cond ((atom? l) (cons l '*))
  744.              ((zero? n) (cons (car l) 0))
  745.              (else (list-ref-* (cdr l) (-1+ n))))))
  746.  
  747.        (parent car)
  748.  
  749.       ;----------------------------------------------------------;
  750.       ;  Smart-list-tail                         ;
  751.       ;  This is used in the modifying commands.  It allows the  ;
  752.       ;  calling function to figure out if there is an nth         ;
  753.       ;  element.  An atom is returned if it there are not n     ;
  754.       ;  elements.    The value of this command is used in set-car!;
  755.       ;  and set-cdr!.  Thus it cannot be an atom.             ;
  756.       ;----------------------------------------------------------;
  757.        (smart-list-tail
  758.          (letrec ((loop
  759.             (lambda (l n)
  760.               (cond ((zero? n) l)
  761.                 ((atom? l) '**atom-returned**) ;PRK 53085
  762.                 (else (loop (cdr l) (-1+ n)))))))
  763.            (lambda (l n)
  764.          (if (< n 0)
  765.              '**atom-returned**
  766.              (loop l n)))))
  767.  
  768.        (not-enough-elements-error
  769.          (lambda (n)
  770.            (newline)
  771.            (writeln "  ?  There are not " n " elements")))
  772.  
  773.        (circular-error
  774.          (lambda (n)
  775.            (newline)
  776.            (writeln
  777.            "  ?  FP is a circular list, can't use negative numbers: "
  778.            n)))
  779.  
  780.        (arg?
  781.          (lambda (a)
  782.            (let ((x (explode a)))
  783.          (if (eq? (car x) '#\#)
  784.              (if (number-range? (cdr x))
  785.              (symbols->number (cdr x) 10 0)
  786.              #F)
  787.              #F))))
  788.  
  789.        (number-range?
  790.          (lambda (l)
  791.            (if (null? l)
  792.            #T
  793.            (let ((a (symbol->ascii (car l))))
  794.              (if (and (> a 47) (< a 58))
  795.              (number-range? (cdr l))
  796.              #F)))))
  797.  
  798.        (symbols->number
  799.          (lambda (l b n)
  800.            (if (null? l)
  801.            0
  802.            (+ (symbols->number (cdr l) b (1+ n))
  803.               (* (expt b n)
  804.              (- (symbol->ascii (car l)) 48))))))
  805.  
  806. ;--------------------------------------------------------------------;
  807. ;                                     ;
  808. ;                 Variables                     ;
  809. ;                                     ;
  810. ;--------------------------------------------------------------------;
  811.  
  812.        (very-top #F)
  813.        (initial-stack '())
  814.        (fp '())
  815.        (stack '())
  816.        (command '())
  817.        (done? #F)
  818.        (buffer '())
  819.  
  820.  
  821. ;--------------------------------------------------------------------;
  822. ;                                     ;
  823. ;             Debugging Functions                 ;
  824. ;                                     ;
  825. ;--------------------------------------------------------------------;
  826.  
  827.        (ps (lambda () (print (print-depth-length stack 4 10))))
  828.  
  829.  
  830.        )
  831.  
  832.     (lambda (l)
  833.       (set! done? #F)
  834.       (set! fp l)
  835.       (set! very-top (list fp))
  836.       (set! initial-stack (list (list* very-top 1)))
  837.       (set! stack initial-stack)
  838.       (read-eval-print-loop))))
  839.